home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / edit / ae_14.zip / AE1.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-08  |  22KB  |  611 lines
  1. unit AE1 ;
  2.  
  3. {$B-}
  4. {$I-}
  5. {$S+}
  6. {$V-}
  7.  
  8. {-----------------------------------------------------------------------------}
  9. { This unit contains all basic procedures                                     }
  10. {-----------------------------------------------------------------------------}
  11.  
  12. interface
  13.  
  14. uses Crt,Dos,AE0 ;
  15.  
  16. function UpperCase (S:string) : string ;
  17. function WordToString (Num:word ; Len:integer) : string ;
  18. function Wildcarded (Name : PathStr) : boolean ;
  19. function Exists (FileName : PathStr) : boolean ;
  20. procedure MoveToScreen (var Source,Dest ; Len : word) ;
  21. procedure MoveFromScreen (var Source,Dest ; Len : word) ;
  22. procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
  23. procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
  24. function Grow (Index:word ; Chars:word) : boolean ;
  25. procedure Shrink (Index:word ; Chars:word) ;
  26. function GetCursor : byte ;
  27. procedure SetCursor (Cursor : byte) ;
  28. procedure CursorTo (X,Y : byte) ;
  29. procedure WarningBeep ;
  30. function ReadKeyNr : word ;
  31. procedure SetBottomLine (LineText:string) ;
  32. procedure Message (Contents:string) ;
  33. procedure ErrorMessage (ErrorNr:byte) ;
  34. procedure Pause ;
  35. procedure CheckDiskError ;
  36. procedure PutFrame (X1,Y1,X2,Y2 : byte ; Border : string) ;
  37. procedure ClearArea (X1,Y1,X2,Y2 : byte) ;
  38. procedure ClearWorkspace (Wsnr:byte) ;
  39. procedure ClearKeyBuffer ;
  40.  
  41. implementation
  42.  
  43. {-----------------------------------------------------------------------------}
  44. { Converts all lower case letters in a string to upper case.                  }
  45. {-----------------------------------------------------------------------------}
  46.  
  47. function UpperCase (S : string) : string ;
  48.  
  49. var Counter : word ;
  50.  
  51. begin
  52. for Counter := 1 to Length(S) do S[Counter] := UpCase (S[Counter]) ;
  53. UpperCase := S ;
  54. end ;
  55.  
  56. {-----------------------------------------------------------------------------}
  57. { Converts an expression of type word to a string                             }
  58. { if Len < 0 then string is adjusted to the left; string length is <Len>      }
  59. { if Len > 0 then string is adjusted to the right; string length is <-Len>    }
  60. { if Len = 0 then string is not adjusted; string has minimum length           }
  61. {-----------------------------------------------------------------------------}
  62.  
  63. function WordToString (Num:word ; Len:integer) : string ;
  64.  
  65. var S : string[5] ;
  66.  
  67. begin
  68. if Len > 0
  69.    then Str (Num:Len,S)
  70.    else begin
  71.         Str (Num,S) ;
  72.         Len := - Len ;
  73.         if (Len > 0) and (Length(S) < Len)
  74.            then begin
  75.                 FillChar (S[Length(S)+1],Len-Length(S),' ') ;
  76.                 S[0] := Chr(Len) ;
  77.                 end ;
  78.         end ;
  79. WordToString := S ;
  80. end ;
  81.  
  82. {-----------------------------------------------------------------------------}
  83. { Deletes all spaces on the left of a string.                                 }
  84. {-----------------------------------------------------------------------------}
  85.  
  86. function TrimLeft (S:string) : string ;
  87.  
  88. begin
  89. while (Length(S) >0) and (S[1] = ' ') do Delete (S,1,1) ;
  90. TrimLeft := S ;
  91. end ;
  92.  
  93. {-----------------------------------------------------------------------------}
  94. { Indicates whether a filename contains wildcard characters                   }
  95. {-----------------------------------------------------------------------------}
  96.  
  97. function Wildcarded (Name : PathStr) : boolean ;
  98.  
  99. begin
  100. Wildcarded := (Pos('*',Name) <> 0) or (Pos('?',Name) <> 0) ;
  101. end ;
  102.  
  103. {-----------------------------------------------------------------------------}
  104. { Returns True if the file <FileName> exists, False otherwise.                }
  105. {-----------------------------------------------------------------------------}
  106.  
  107. function Exists (FileName : PathStr) : boolean ;
  108.  
  109. var SR : SearchRec ;
  110.  
  111. begin
  112. FindFirst (FileName,ReadOnly + Hidden + SysFile,SR) ;
  113. Exists := (DosError = 0) and (not Wildcarded(Filename)) ;
  114. end ;
  115.  
  116. {-----------------------------------------------------------------------------}
  117. { Moves <Len> bytes of memory to screen memory.                               }
  118. { From the TCALC spreadsheet program delivered with every copy of Turbo       }
  119. { Pascal 5.5                                                                  }
  120. {-----------------------------------------------------------------------------}
  121.  
  122. procedure MoveToScreen (var Source,Dest ; Len : word) ;
  123.  
  124. external ;
  125.  
  126. {-----------------------------------------------------------------------------}
  127. { Moves <Len> bytes of screen memory to memory.                               }
  128. { From the TCALC spreadsheet program delivered with every copy of Turbo       }
  129. { Pascal 5.5                                                                  }
  130. {-----------------------------------------------------------------------------}
  131.  
  132. procedure MoveFromScreen (var Source,Dest ; Len : word) ;
  133.  
  134. external ;
  135.  
  136. {$L TCMVSMEM.OBJ }
  137.  
  138. {-----------------------------------------------------------------------------}
  139. { Saves the contents of a rectangular part of the screen to memory.           }
  140. { Upper left corner is (X1,Y1), lower right is (X2,Y2)                        }
  141. { Also claims the amount of memory needed.                                    }
  142. {-----------------------------------------------------------------------------}
  143.  
  144. procedure SaveArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
  145.  
  146. var LineLen : byte;
  147.     Index : word;
  148.     Counter : byte;
  149.  
  150. begin
  151. LineLen := X2 - X1 + 1;
  152. GetMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
  153. Index := 1 ;
  154. for Counter := Y1 to Y2 do
  155.     begin
  156.     MoveFromScreen (DisplayPtr^[Counter,X1],MemPtr^[Index],LineLen*2);
  157.     Inc (Index,LineLen)
  158.     end;
  159. {$IFDEF DEVELOP }
  160. if MemAvail < MinMemAvail
  161.    then MinMemAvail := MemAvail ;
  162. {$ENDIF }
  163. end;
  164.  
  165. {-----------------------------------------------------------------------------}
  166. { Reverse of SaveArea                                                         }
  167. {-----------------------------------------------------------------------------}
  168.  
  169. procedure RestoreArea (X1,Y1,X2,Y2:word ; var MemPtr:ScreenBlockPtr) ;
  170.  
  171. var LineLen : byte;
  172.     Index : word;
  173.     Counter : byte;
  174.  
  175. begin
  176. LineLen := X2 - X1 + 1;
  177. Index := 1;
  178. for Counter := Y1 to Y2 do
  179.     begin
  180.     MoveToScreen (MemPtr^[Index],DisplayPtr^[Counter,X1],LineLen*2);
  181.     Inc (Index,LineLen)
  182.     end;
  183. FreeMem (MemPtr,LineLen*(Y2-Y1+1)*2) ;
  184. end;
  185.  
  186. {-----------------------------------------------------------------------------}
  187. { Expands the text in the buffer of the current workspace at position         }
  188. { <Index> by <Chars> characters. Function result is False if there is not     }
  189. { enough space left, True otherwise.                                          }
  190. { Index values of Mark and in position stack are adapted                      }
  191. {-----------------------------------------------------------------------------}
  192.  
  193. function Grow (Index:word ; Chars:word) : boolean ;
  194.  
  195. var Counter : byte ;
  196.  
  197. begin
  198. with Workspace[CurrentWsnr] do
  199.      if Chars > (WsBufSize - BufferSize)
  200.         then begin
  201.              { not enough space }
  202.              ErrorMessage (1) ;
  203.              Grow := False ;
  204.              end
  205.         else begin
  206.              { move rest of text forward }
  207.              Move (Buffer^[Index],Buffer^[Index+Chars],BufferSize-Index+1) ;
  208.              Inc (BufferSize,Chars) ;
  209.              { adapt Mark and position stack }
  210.              if Mark >= Index then Inc (Mark,Chars) ;
  211.              for Counter := 1 to PosStackpointer do
  212.                  begin
  213.                  if PosStack[Counter] >= Index
  214.                     then Inc (PosStack[Counter],Chars) ;
  215.                  end ;
  216.              ChangesMade := True ;
  217.              Grow := True ;
  218.              end ;
  219. end ;
  220.  
  221. {-----------------------------------------------------------------------------}
  222. { Deletes <Chars> characters from the buffer in the current workspace,        }
  223. { starting on position <Index>.                                               }
  224. { Index values of Mark and in position stack are adapted                      }
  225. {-----------------------------------------------------------------------------}
  226.  
  227. p